home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / XLISP 3.0a1 / XLISP.INI < prev    next >
Text File  |  1995-03-11  |  5KB  |  187 lines
  1. ; xlisp.ini - initialization code for XLisp version 3.0b
  2.  
  3. (define ld load)
  4.  
  5. (ld "qquote.lsp")
  6. (ld "macros.lsp")
  7. (ld "math.lsp")
  8. ;(ld "clisp.lsp")
  9. (ld "objects.lsp")
  10. (ld "fasl.lsp")
  11. (ld "crec.lsp")
  12. (ld "pp.lsp")
  13.  
  14. ; this version of EVAL knows about the optional enviroment parameter
  15. (define (eval x &optional env)
  16.   ((compile x env)))
  17.  
  18. (define basic-apply apply)
  19. (define (apply f &rest args)
  20.   (basic-apply f (basic-apply list* args)))
  21.  
  22. (define (autoload-from-file file syms &optional env)
  23.   (map (lambda (sym) (put sym '%autoload file)) syms)
  24.   '())
  25.   
  26. (define (*unbound-handler* sym cont)
  27.   (let ((file (get sym '%autoload)))
  28.     (if file (load file))
  29.     (if (bound? sym)
  30.       (cont '()))
  31.     (error "unbound variable ~S" sym)))
  32.  
  33. (define head car)
  34. (define (tail x) (force (cdr x)))
  35. (define empty-stream? null?)
  36. (define the-empty-stream '())
  37.  
  38. (macro cons-stream
  39.   (lambda (x)
  40.     (list 'cons (cadr x) (list 'delay (caddr x)))))
  41.  
  42. (macro make-environment
  43.   (lambda (x)
  44.     (append '(let ()) (cdr x) '((the-environment)))))
  45.  
  46. (define initial-user-environment (the-environment))
  47.  
  48. (define (set-macro-character char fun &optional (non-terminating? #f) (table *readtable*))
  49.   (let ((type (if non-terminating? 'non-terminating-macro 'terminating-macro)))
  50.     (vector-set! table (char->integer char) (cons type fun))
  51.     #t))
  52.     
  53. (define (get-macro-character char &optional (table *readtable*))
  54.   (let ((entry (vector-ref table (char->integer char))))
  55.     (when (and (pair? entry) (not (vector? (cdr entry))))
  56.       (values (cdr entry) (eq? (car entry) 'nmacro)))))
  57.  
  58. (define (make-dispatch-macro-character char &optional (non-terminating? #f) (table *readtable*))
  59.   (let ((type (if non-terminating? 'non-terminating-macro 'terminating-macro)))
  60.     (vector-set! table (char->integer char) (cons type (make-vector 256)))
  61.     #t))
  62.   
  63. (define (set-dispatch-macro-character dchar char fun &optional (table *readtable*))
  64.   (let ((entry (vector-ref table (char->integer dchar))))
  65.     (unless (vector? entry)
  66.       (error "not a dispatch macro character ~S" dchar))
  67.     (vector-set! entry (char->integer char) fun)
  68.     #t))
  69.     
  70. (define (get-dispatch-macro-character dchar char &optional (table *readtable*))
  71.   (let ((entry (vector-ref table (char->integer dchar))))
  72.     (unless (and (pair? entry) (vector? (cdr entry)))
  73.       (error "not a dispatch macro character ~S" dchar))
  74.     (vector-ref (cdr entry) (char->integer char))))
  75.  
  76.     
  77. (define (%get-method-list class)
  78.   (%vector-ref class 2))
  79.   
  80. (define (%get-superclass class)
  81.   (%vector-ref class 5))
  82.  
  83. (define (%find-method class selector)
  84.   (let ((s (assoc selector (%get-method-list class))))
  85.     (if s
  86.       (cdr s)
  87.       (let ((super (%get-superclass class)))
  88.         (if super
  89.           (%find-method super selector))))))
  90.  
  91. (define-macro (instruction-trace &body body)
  92.   `(begin
  93.      (trace-on)
  94.      (unwind-protect
  95.        (begin ,@body)
  96.        (trace-off))))
  97.  
  98. (define *editor* "ep")
  99.  
  100. (define (ed &optional file)
  101.   (if file
  102.     (system (string-append *editor*  " " file))
  103.     (system *editor*)))
  104.  
  105. ; load the files mentioned on the command line
  106. (define (loader n)
  107.   (let ((arg (getarg n)))
  108.     (if arg
  109.       (begin
  110.         (newline)
  111.         (display ";Loading ")
  112.         (write arg)
  113.         (if (not (load arg))
  114.           (display " -- failed"))
  115.         (loader (1+ n))))))
  116. (loader 1)
  117.  
  118. ; read/eval/print loop history routines
  119.  
  120. (define *history-stack-size* 20)
  121.  
  122. (define (setup-history size)
  123.   (set! *history-n* 0)
  124.   (set! *history-exprs* (make-vector size))
  125.   (set! *history-values* (make-vector size)))
  126.  
  127. (setup-history *history-stack-size*)
  128.  
  129. (define (next-history-n)
  130.   (+ *history-n* 1))
  131.  
  132. (define (store-history expr values)
  133.   (push-history-value expr *history-exprs*)
  134.   (push-history-value values *history-values*)
  135.   (set! *history-n* (1+ *history-n*))
  136.   *history-n*)
  137.  
  138. (define (push-history-value value vect)
  139.   (let loop ((i (-1+ (vector-length vect))))
  140.     (when (> i 0)
  141.       (vector-set! vect i (vector-ref vect (-1+ i)))
  142.       (loop (-1+ i))))
  143.   (vector-set! vect 0 value)
  144.   vect)
  145.  
  146. (define (get-history-value vect n)
  147.   (let ((i (- *history-n* n)))
  148.     (if (and (>= i 0) (< i (vector-length vect)))
  149.       (vector-ref vect i)
  150.       (values))))
  151.     
  152. ; get an expression from the history stack
  153. (define (%e n)
  154.   (get-history-value *history-exprs* n))
  155.  
  156. ; get a value from the history stack
  157. (define (%v n &optional (i 0))
  158.   (list-ref (get-history-value *history-values* n) i))
  159.  
  160. (define (*toplevel*)
  161.   (catch 'error
  162.     (fresh-line)
  163.     (format #t "[~S] " (next-history-n))
  164.     (let* ((expr (read))
  165.            (vals (multiple-value-list (eval expr))))
  166.       (store-history expr vals)
  167.       (for-each (lambda (v) (fresh-line) (write v)) vals)))
  168.   (*toplevel*))
  169.  
  170. (define (*breaklevel* env)
  171.   (fresh-line)
  172.   (format #t "Debug [~S] " (next-history-n))
  173.   (let* ((expr (read))
  174.          (vals (multiple-value-list (eval expr env))))
  175.     (store-history expr vals)
  176.     (for-each (lambda (v) (fresh-line) (write v)) vals))
  177.   (*breaklevel* env))
  178.  
  179. (define (*error-handler* fun env)
  180.   (format t "~%Entering break loop ('(reset)' to quit)")
  181.   (*breaklevel* env))
  182.   
  183. (define (*initialize*)
  184.   (loader 1)
  185.   (*toplevel*))
  186.  
  187. (load "local.ini")